perm filename T3.F4[M11,LCS]1 blob
sn#373981 filedate 1978-08-02 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SUBROUTINE MSCAN(LL,W)
C00016 ENDMK
C⊗;
SUBROUTINE MSCAN(LL,W)
DIMENSION W(1),TONES(21)
COMMON /TR/I(80),RX(100),JX(100),LX(12),INST(27,5),MX5(40)
1,INSNUM(27),P(30),NPAR(27),JSEM,IPRNT,IPP
1,SRATE,RNCHN,RMAG,INUM,INS,MM,M,N,JJ,X,Y,IK
1,ENDX,J /KNAM/KNAM,IPLAY,JFLNM,IOPEN
COMMON /SBFILN/SBFILN /AR/IOP /IGEN/IGEN /JP/JPRNT,JWRT
C OUT, OSC, AD2, RAN, ENV, STR, AD3, AD4, MLT, SET, RAH, GEN
CXX DOUBLE PRECISION JFLNM
INTEGER RPR
EQUIVALENCE (LESS,LX(9)),
1 (RX2,RX(3)),(P2,P(2)),(RX3,RX(5)),(I3,I(3))
1 ,(ISEMI,LX(2)),(IAST,LX(3))
1,(LPR,LX(11)),(RPR,LX(12)),(ICOM,LX(10)),(LAROW,LX(7))
DATA TONES/246.945,261.62,277.18,277.8,293.66,311.13,311.13,
1 329.63,349.23,329.63,349.23,369.99,369.99,
1 391.99,415.31,415.31,440.0,466.16,466.16,493.89,523.24/
C**** CODE NUMS. 1=OUT 2=OSC 3=AD2 4=RAN 5=END 6=STR 7=AD3 8=AD4 9=MLT
C**** 10=SET 11=RAH 12=END 13=INS 14=OPT B1=101 ETC. P1=201 ETC. F1=301 ETC.
C**** 400=PLAY 401=FINI 402=SRATE 403=NCHNS 404=PRINT 405=CHA 406=POWER
C**** 407=SRT 409=GEN 410=DUR 411=FREQ 412=INSTRUMENT 413=UNIT GEN.
C**** 500=CF 501=C 502=CS 503=DF 504=D 505=DS 506=EF 507=E 508=ES 509=FF
C**** 510=F 511=FS 512=GF 513=G 514=GS 515=AF 516=A 517=AS 518=BF 519=B 520=BS
30 IF(JSEM.NE.0)GO TO 34
LL=1
INS=-1
34 J=J+2
2324 FORMAT(1X20F10.3/)
2325 FORMAT(1X20I/)
2323 FORMAT(1X20A1/)
IXJ=JX(J)
IPP=0
C!FOR 'P3←333;' ETC.
IPOW=0
IOP=-1
IF(IXJ.NE.ISEMI)GO TO 9
10 IF(IGEN.GT.100)W(3)=IGEN
15 JSEM=-1
RETURN
9 IF(J.GE.MM)GO TO 1001
IF(RX(J+1).EQ.-9999.0)GO TO 11
C!*** SKIP IF NUMBER
IF(IGEN.GT.0)GO TO 450
C!***** LOOK FOR SPECIAL WORDS
IF(IXJ/400.NE.1)GO TO 32
K=IXJ-399
GO TO (3,13,304,303,302,303,4,505,505,422)K
32 IF(IXJ.NE.13)GO TO 402
C 13='INS'
KNAM=IXJ
W(1)=2
IGEN=2
GO TO 424
505 JK=4
C !**** FOR SRATE OR SRT
IF(K.NE.4)JK=2
JK=J+JK
GO TO 304
450 K=IXJ
C** HERE FOR INST DEFINITIONS.
IF(K.LE.13.AND.K.GT.0)GO TO(425,425,425,425,425
1,425,425,425,425,425,425,411),K
IF(K.EQ.14)GO TO 425
C 14='OPT' USER-ADDED UNIT GENERATOR.
DO 451 JK=1,40,2
C!*** FOR USER-ADDED UNIT GENS. (UP TO 20)
IF(MX5(JK).NE.IXJ)GO TO 451
W(3)=MX5(JK+1)
GO TO 426
451 CONTINUE
CCC503 IF(JPRNT.LT.0)TYPE 504,IXJ
503 JSEM=0
J=MM
RETURN
504 FORMAT(' UNKNOWN SYMBOL ',A2)
411 LL=3
KNAM=IXJ
IGEN=1
C!*** =1 IS FLAG TO CHANGE IT TO -1
J=MM
INS=-1
GO TO 10
422 W(1)=3
C!***** GEN
KNAM=IXJ
IGEN=0
424 INS=-1
LL=2
GO TO 36
425 W(3)=K+100
426 KNAM=IXJ
436 LL=4
GO TO 36
3 J=J+2
C !**** FOUND 'PLAY;'
IF(JX(J).NE.ISEMI)CALL ERR(1)
IPLAY=-1
JSEM=-1
IF(J.LT.MM)GO TO 34
JSEM=0
PAUSE 'BEFORE LABEL 4'
RETURN
4 JL=LL
JOP=IOP
J=J+2
IF(JX(J).NE.LPR)CALL ERR(2)
IPOW=-1
IOP=-1
GO TO 36
C!**FIND NUM UP TO THE COMMA
7 IF(IPOW.GT.0)GO TO 8
IPOW=1
GO TO 36
8 LL=LL-2
W(LL)=W(LL)**W(LL+1)
IPOW=0
IOP=JOP
C!** GET BACK FLAGS
GO TO 38
302 LL=1
IPRNT=-1
C!***** FOR 'PRINT' FEATURE
GO TO 36
304 SRATE=RX(J+4)
J=J+6
RMAG=512./SRATE
W(3)=4
W(4)=SRATE
351 W(1)=11
W(2)=0
IGEN=0
LL=5
GO TO 15
CCC303 IF(IXJ.EQ.405)J=J-2
303 RNCHN=RX(J+4)
C!**** FOR NCHNS←N; OR CHA ← N;
J=J+6
CC IF(RX(JK+1).NE.-9999.0)JK=JK+2
C!*** SKIP A COMMA
CC IF(JX(JK+2).EQ.ISEMI)GO TO 352
C!*** FOR NCHNS←n;
352 W(3)=8
C!*** FOR NCHNS
W(4)=RNCHN-1
GO TO 351
35 IF(IPLAY.GE.0)CALL ERR(4)
W(2)=INSNUM(IK)
C!**** W IS P ARRAY IN MUSIC5
LL=3
C!**** W(2) AND W(3) WILL BE EXCHANGED LATER
KNAM=IXJ
36 J=J+2
IF(J.GT.MM)GO TO 1001
C!****** 50 = DONE
CC JK=J*2
IXJ=JX(J)
CX TYPE 2324,RX(J+1)
CX TYPE 2323,IXJ
CX TYPE 2325,IXJ,IOP,IGEN
CX PAUSE 'LABEL 36'
IF(IXJ.NE.ISEMI)GO TO 1
JSEM=-1
1000 IF(IPP.EQ.0)GO TO 10
P(IPP)=W(1)
LL=1
IPP=0
IF(J.LT.MM)GO TO 30
INS=-1
C!*** I HOPE THIS IS THE RIGHT PLACE FOR THIS.
1001 IF(IGEN.EQ.0.OR.JSEM.EQ.0)JSEM=1
IF(JSEM)JSEM=0
CX PAUSE 'LABEL 1001'
RETURN
1 IF(RX(J+1).NE.-9999.0)GO TO 2
CX TYPE 2325,IOP
CX PAUSE 'LABEL 1'
11 IF(IOP.LT.0)GO TO 40
IF(IOP.NE.5)GO TO 12
RX(J)=-RX(J)
C!*** IOP=5 MEANS MINUS WITH COMMA IN FRONT
W(LL)=RX(J)
LL=LL+1
GO TO 14
12 CALL ARITH(RX(J),W,LL)
14 IOP=-1
C!*** RESET OPERATOR FLAG
GO TO 36
C!*** USE PARENTH'S FOR COMPOSITE EXPRESSIONS!!!!
40 W(LL)=RX(J)
38 LL=LL+1
IF(IOP.LT.0)GO TO 36
C IOP = NEG = NO OPERATOR BEFORE THIS ITEM.
LL=LL-1
380 CALL ARITH(W(LL),W,LL)
GO TO 14
402 IF(JSEM.GT.0)GO TO 2
C!**** READING CONTINUATION LINE.
IF(IXJ.GE.0)GO TO 33
C NEXT TRIES TO FIND INST. NAME.
NA=-1-IXJ
M=JX(J+1)
C NA POINTS TO SPOT IN I ARRAY, M IS WDCNT.
DO 133 IK=1,INUM
DO 233 II=1,M
233 IF(INST(IK,II).NE.I(II+NA))GO TO 133
C NOW WE FOUND AN INST. NAME.
C******* INST NAMES CANNOT HAVE SAME STRING OF 1ST LETTERS AS OTHER THINGS.
333 IF(M.EQ.5)GO TO 35
M=M+1
IF(INST(IK,M).EQ.0)GO TO 333
133 CONTINUE
33 INS=2
C! NEXT IS SOMETHING OUTSIDE OF INST. AND PARAMS.
2 IF(IGEN.GT.0)GO TO 427
IF(IXJ.GT.520)GO TO 341
IF(IXJ.LT.500)GO TO 427
C NOW FOUND A NOTE
K=IXJ-499
W(LL)=TONES(K)
GO TO 38
C!***** FINDS NOTE IN SCALE
C!****** FIND A PARAM NUM.
427 IF(IXJ.GE.300)GO TO 307
IF(IXJ.LT.200)GO TO 344
K=IXJ-200
C NOW K HAS PARAM NUM.
IF(INS.LE.0)GO TO 340
JK=J+2
IF(JX(JK).NE.LAROW)GO TO 340
IPP=K
LL=1
J=JK
GO TO 36
340 W(LL)=P(K)
C!***** FOUND Pn
IF(IPRNT.LT.0)GO TO 38
IF(IGEN.GT.0)W(LL)=K+2.
C!*** PARAM NUMS ARE 2 LESS THAN IN BOOK.
GO TO 38
C!**** P4 IS CHANGED TO 6
307 IF(IXJ.GE.400)GO TO 344
IF(IXJ/300.NE.1)GO TO 344
JL=IXJ-300
IF(IGEN.GT.0)JL=-JL-100
C!*** FOR Fn IN INST DEFINITION
W(LL)=JL
GO TO 38
344 CONTINUE
IF(IGEN.LE.0)GO TO 341
C*** FOR B1, ETC. IN INST. DEFS.
IF(IXJ/100.NE.1)GO TO 341
W(LL)=100-IXJ
GO TO 38
342 CONTINUE
341 DO 39 K=3,6
IF(LX(K).NE.IXJ)GO TO 39
IOP=K-2
JK=JX(J-2)
IF(JK.EQ.ICOM)IOP=5
C!** COMMA DISABLES NEXT OPERATOR
IF(JK.EQ.LAROW)IOP=5
C!** ← DISABLES NEXT OPERATOR
IF(JK.EQ.LPR)IOP=5
C!** LFT PARENTH. DISABLES NEXT OPERATOR
GO TO 36
39 CONTINUE
308 IF(IXJ.EQ.LAROW)GO TO 36
C!*** PASS LEFT ARROW
IF(IXJ.EQ.406)GO TO 4
C 406='POWER'
IF(IXJ.EQ.RPR)GO TO 500
IF(IXJ.EQ.LPR)GO TO 500
C LEFT AND RIGHT PARENTHESES
IF(IXJ.NE.402)GO TO 510
C 402=SRATE
W(LL)=SRATE
335 LL=LL+1
GO TO 36
C**** OR SHOULD NEXT BE 403???
510 IF(IXJ.NE.403)GO TO 511
C 403-'NCHNS'
W(LL)=RNCHN
GO TO 335
511 IF(IXJ.NE.ICOM)GO TO 503
C!***** UNKNOWN CHAR.
500 IF(IPOW.NE.0)GO TO 7
IF(IXJ.NE.LPR)GO TO 501
JPOW=IPOW
IPOW=0
KOP=IOP
IOP=-1
JL=LL
C!**** SAVE VARIOUS POINTERS WHEN INSIDE PARENTHS.
GO TO 36
501 IF(IXJ.NE.RPR)GO TO 502
IPOW=JPOW
C!*** GET BACK STUFF
IOP=KOP
IF(IOP.LT.0)GO TO 36
LL=JL
GO TO 380
C!GO DO ARITHMETIC
502 IF(IPRNT)GO TO 36
C!**** FOUND COMMA IN PRINT STATEMENT.
5 IF(JX(J-2).NE.ICOM)GO TO 132
433 W(LL)=P(LL-2)
C!** ONLY CARES ABOUT 2 COMMAS IN A ROW
GO TO 335
132 IF(INS.GE.0)GO TO 36
IF(LL.EQ.3)GO TO 433
C!*** =3 MEANS COMMA FOR P1.
GO TO 36
13 LL=2
IPLAY=0
C!*** TURN OFF PLAY FLAG
W(1)=6
W(2)=ENDX+.5
C!***** ENDX IS P1+P2 OF THE LONGEST LASTING INST.
IF(JPRNT)TYPE 51,LL,W(1),W(2)
IF(JWRT.GE.0)GO TO 130
WRITE(21)LL,W(1),W(2)
CZZ CALL CLOSE(1)
END FILE(21)
CXX CALL CLOSE(21)
IOPEN=-1
TYPE 131,JFLNM
130 J=MM
JSEM=99
C!*** WON'T READ LINE BEYOND 'FINISH;' ***************
ENDX=-1
51 FORMAT(I3,35F10.3)
131 FORMAT(9X,A4,'.DAT WAS WRITTEN *****')
END